home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / m68_bignum.t < prev    next >
Text File  |  1988-02-05  |  6KB  |  176 lines
  1. (herald m68_bignum (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. (define (set-bignum-length! bignum length)
  27.   (lap ()  
  28.     (move .l (d@r A1 -2) S0)       ; get header
  29.     (asr .l ($ 6) S0)              ; length in bytes
  30.     (and .b ($ #b11111100) S0)
  31.     (sub .l A2 S0)                 ; size of bogus bytev including header
  32.     (sub .l ($ 4) S0)              ; bytev length
  33.     (asl .l ($ 8) S0)
  34.     (move .b ($ header/bytev) S0)  ; bogus bytev header
  35.     (move .l S0 (index (d@r A1 2) A2))
  36.     (move .l A2 S0)                ; new length
  37.     (asl .l ($ 6) S0)
  38.     (move .b (d@r A1 1) S0)
  39.     (move .l S0 (d@r A1 -2))
  40.     (move .l ($ -2) NARGS)
  41.     (move .l (@r sp) tp)
  42.     (jmp (@r tp))))
  43.  
  44. (define-constant (bignum-positive? bignum)   ; if bit 7 of header is on
  45.   (fx= (mref-8-u bignum -1) 
  46.        (fixnum-add header/bignum 128)))
  47.  
  48. (define-constant bignum-negate!
  49.   (primop bignum-negate! ()
  50.     ((primop.side-effects? self) t)
  51.     ((primop.generate self node)                               
  52.      (let ((reg (->register 'pointer node (leaf-value ((call-arg 2) node)) '*)))
  53.        (emit m68/bchg (machine-num 7) (reg-offset reg 1))))
  54.     ((primop.type self node)
  55.      '#[type (proc #f (proc #f top) bignum)])))
  56.  
  57.  
  58. (define (%digit-divide x1 x0 y)   ; Divide x1x0 by y with x1 < (* 2 y)
  59.   (lap ()
  60.     (move .l A1 S0)             ; Remainder will be in S0
  61.     (lsr .l ($ 2) S0)
  62.     (move .l A2 S1)
  63.     (move .l A3 S2)
  64.     (lsr .l ($ 2) S2)
  65.  
  66.     (move .l ($ 30) s3)
  67.     (clr .l s4)                ; Quotient in S4
  68.     (jmp (label integer-divide-start))
  69.  
  70. integer-divide-loop
  71.     (lsl .l ($ 1) s4)
  72.     (lsl .l ($ 1) s1)
  73.     (roxl .l ($ 1) s0)
  74.  
  75. integer-divide-start
  76.     (cmp .l s2 s0)
  77.     (uj< integer-divide-next)
  78.     (sub .l s2 s0)
  79.     (or .b ($ 1) s4)
  80. integer-divide-next
  81.     (dbcc 'f s3 (to integer-divide-loop))
  82.  
  83.     (lsl .l ($ 2) S4)
  84.     (move .l S4 A1)
  85.     (lsl .l ($ 2) S0)
  86.     (move .l S0 A2)
  87.     (move .l ($ -3) nargs)
  88.     (move .l (@r sp) tp)
  89.     (jmp (@r tp))))
  90.  
  91.  
  92. (comment
  93. (define (%digit-add u v carry)    ; U + V + carry => sum and carry-out 
  94.   (lap ()                         ; carry is 0 or 1 (T integers)
  95.     (move .l A1 S0)
  96.     (move .l A2 S1)
  97.     (move .l A3 S3)
  98.  
  99.     (lsr .l ($ 3) S3)     ; Carry in => X
  100.     (addx .l S1 S0)                            ; TAS can't do this
  101.     (roxl .b ($ 3) S3)    ; Carry out => S3
  102.  
  103.     (move .l S0 A1)
  104.     (move .l S3 A2)
  105.     (move .l ($ -3) nargs)
  106.     (jmp (d@r task task/ireturn))))
  107.  
  108. (define (%digit-subtract u v carry) ; U - V - carry => sum and carry-out 
  109.   (lap ()                           ; carry is 0 or 1 (T integers)
  110.     (move .l A1 S0)
  111.     (move .l A2 S1)
  112.     (move .l A3 S3)
  113.  
  114.     (lsr .l ($ 3) S3)     ; Carry in => X
  115.     (subx .l S1 S0)                            ; TAS can't do this
  116.     (roxl .b ($ 3) S3)    ; Carry out => S3
  117.  
  118.     (move .l S0 A1)
  119.     (move .l S3 A2)
  120.     (move .l ($ -3) nargs)
  121.     (jmp (d@r task task/ireturn))))
  122.  
  123. (define (%digit-multiply u v)   ; Multiply U and V
  124.   (lap ()
  125.     (move .l a1 s1)
  126.     (asr .l ($ 2) s1)          ;       convert 1 fixnum to machine num
  127.     (move .l a2 s0)
  128.  
  129.     (move .w s1 s2)
  130.     (mulu s0 s2)           ; low-u * low-v
  131.  
  132.     (swap s1)
  133.     (move .w s1 s3)
  134.     (mulu s0 s3)           ; high-u * low-v
  135.  
  136.     (swap s0)
  137.     (move .w s1 s4)
  138.     (mulu s0 s4)           ; high-u * high-v
  139.  
  140.     (swap s1)
  141.     (mulu s0 s1)           ; low-u * high-v
  142.  
  143.     (swap s2)
  144.  
  145.     (move .w s3 s0)
  146.     (clr .w s3)
  147.     (swap s3)
  148.     (add .w s0 s2)         ; low-(high-u * low-v) + high-(low-u * low-v)
  149.     (addx .l s3 s4)        ; high-(high-u * low-v) + low(high-u * high-v)
  150.                                                ; TAS can't do this
  151.     (move .w s1 s0)
  152.     (clr .w s1)
  153.     (swap s1)
  154.     (add .w s0 s2)         ; low-(high-v * low-u) + high-(low-u * low-v)
  155.     (addx .l s3 s4)        ; high-(high-v * low-u) + low(high-u * high-v)
  156.                                                ; TAS can't do this
  157.     (swap s2)
  158.  
  159.     (move .l s2 a2)
  160.     (move .l s4 a1)
  161.     (move .l ($ -3) nargs)
  162.     (jmp (d@r task task/ireturn))))
  163. )
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.                                                
  176.